home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 001-010 / amok03 / intuistruct1.3 / intuistruct.mod < prev    next >
Text File  |  1993-11-04  |  12KB  |  526 lines
  1. (**********************************************************************
  2.  
  3.     :Program.       IntuiStruct.mod
  4.     :Contents.     Easy initializing of Intuition structures
  5.     :CoFiles.     amok#3/IntuiStruct1.3/IntuiStruct.doc
  6.     :Author.        Nicolas Benezan [bne]
  7.     :Address.    Postwiesenstr. 2, D7000 Stuttgart 60
  8.     :Phone.      711/333679
  9.     :Copyright.  Public Domain
  10.     :Language.      Modula-2
  11.     :Translator. M2Amiga AMSoft
  12.     :ModHistory. V1.0a [bne] 23.05.88 (first PD-version, Amok#2)
  13.     :ModHistory. V1.1b [bne] 13.06.88 (extended MemHandler)
  14.     :ModHistory. V1.2d [bne] 05.07.88 (+ StructRequest, StructBorder)
  15.     :ModHistory. V1.3b [bne] 11.07.88 (+ UnlinkMenu, FreeImage)
  16.     
  17. **********************************************************************)
  18.  
  19. IMPLEMENTATION MODULE IntuiStruct;
  20.  
  21. FROM Intuition    IMPORT NewScreen,ScreenFlagSet,NewWindow,IDCMPFlagSet,
  22.         WindowFlagSet,ScreenPtr,stdScreenHeight,Image,ImagePtr,
  23.                 IntuiText,IntuiTextPtr,Gadget,GadgetPtr,GadgetFlagSet,
  24.                 GadgetFlags,ActivationFlagSet,PropInfo,PropInfoFlagSet,
  25.                 StringInfo,Menu,MenuPtr,MenuItem,MenuItemPtr,Point,
  26.                 MenuItemFlagSet,MenuItemFlags,menuEnabled,WindowPtr,
  27.                 RefreshGadgets,RequesterPtr,Requester,BorderPtr,Border,
  28.                 RequesterFlagSet;
  29. FROM Graphics    IMPORT ViewModeSet,ViewModes,DrawModeSet,jam1;
  30. FROM SYSTEM    IMPORT ADR,ADDRESS,BITSET,LONGSET,WORD,CAST;
  31. FROM Exec    IMPORT Byte,UByte;
  32. FROM Arts    IMPORT Assert;
  33.  
  34. CONST    CorruptImage    ="IntuiStruct: Image Struct corrupt";
  35.         CorruptMenu    ="IntuiStruct: Menu Struct corrupt";
  36.         CorruptBorder    ="IntuiStruct: Border Struct corrupt";
  37.         AllocError    ="IntuiStruct: No AllocProc installed";
  38.         DeallocError    ="IntuiStruct: No DealcProc installed";
  39.  
  40. TYPE    WordPtr=POINTER TO CARDINAL;
  41. VAR    CurImagePtr:WordPtr;
  42.     CurBorderPtr:POINTER TO Point;
  43.     ImageSize,BorderSize,Count:INTEGER;
  44.         SubItemPtr,ItemPtr:MenuItemPtr;
  45.         MenuOK:BOOLEAN;
  46.  
  47. PROCEDURE FailAlloc(VAR PadA:ADDRESS;PadL:LONGINT;PadB:BOOLEAN);
  48. BEGIN
  49.   Assert(FALSE,ADR(AllocError));
  50. END FailAlloc;
  51.  
  52. PROCEDURE FailDealloc(VAR PadA:ADDRESS);
  53. BEGIN
  54.   Assert(FALSE,ADR(DeallocError));
  55. END FailDealloc;
  56.  
  57. PROCEDURE StructScreen(VAR NewSc:NewScreen;Depth,Detail,Block:Byte;
  58.     Mode:ViewModeSet;Type:ScreenFlagSet;Title:ADDRESS);
  59. BEGIN
  60.   WITH NewSc DO
  61.     leftEdge:=0;
  62.     topEdge:=0;
  63.     IF hires IN Mode THEN
  64.       width:=640;
  65.     ELSE
  66.       width:=320;
  67.     END;
  68.     height:=stdScreenHeight;
  69.     depth:=Depth;
  70.     detailPen:=CAST(UByte,Detail);
  71.     blockPen:=CAST(UByte,Block);
  72.     viewModes:=Mode;
  73.     type:=Type;
  74.     font:=NIL;
  75.     defaultTitle:=Title;
  76.     gadgets:=NIL;
  77.     customBitMap:=NIL;
  78.   END;
  79. END StructScreen;
  80.  
  81. PROCEDURE StructWindow(VAR NewW:NewWindow;Left,Top,Width,Height:INTEGER;
  82.     Detail,Block:Byte;IDCMP:IDCMPFlagSet;Flags:WindowFlagSet;
  83.         Title:ADDRESS;Screen:ScreenPtr;Type:ScreenFlagSet);
  84. BEGIN
  85.   WITH NewW DO
  86.     leftEdge:=Left;
  87.     topEdge:=Top;
  88.     width:=Width;
  89.     height:=Height;
  90.     detailPen:=CAST(UByte,Detail);
  91.     blockPen:=CAST(UByte,Block);
  92.     idcmpFlags:=IDCMP;
  93.     flags:=Flags;
  94.     firstGadget:=NIL;
  95.     checkMark:=NIL;
  96.     title:=Title;
  97.     screen:=Screen;
  98.     bitMap:=NIL;
  99.     type:=Type;
  100.     minWidth:=0;
  101.     minHeight:=0;
  102.     maxWidth:=0;
  103.     maxHeight:=0;
  104.   END;
  105. END StructWindow;
  106.     
  107. PROCEDURE StructImage(VAR NewImage:Image;Left,Top,Width,Height,Depth:
  108.     INTEGER;Pick,OnOff:BITSET;Next:ImagePtr);
  109. BEGIN
  110.   Assert((ImageSize=0)AND(BorderSize=0),ADR(CorruptImage));
  111.   WITH NewImage DO
  112.     leftEdge:=Left;
  113.     topEdge:=Top;
  114.     width:=Width;
  115.     height:=Height;
  116.     depth:=Depth;
  117.     IF Depth#0 THEN
  118.       ImageSize:=2*depth*height*((width-1)DIV 16 +1);
  119.       AllocProc(imageData,ImageSize,CHIP);
  120.     END;
  121.     planePick:=CAST(CARDINAL,Pick);
  122.     planeOnOff:=CAST(CARDINAL,OnOff);
  123.     nextImage:=Next;
  124.   END;
  125.   Count:=0;
  126.   CurImagePtr:=NewImage.imageData;
  127. END StructImage;
  128.     
  129. PROCEDURE Word(Data:CARDINAL);
  130. BEGIN
  131.   Assert((CurImagePtr#NIL)AND(Count<ImageSize-1),ADR(CorruptImage));
  132.   CurImagePtr^:=Data;
  133.   INC(CurImagePtr,2);
  134.   INC(Count,2);
  135. END Word;
  136.  
  137. PROCEDURE Long(Data:LONGCARD);
  138. BEGIN
  139.   Word(Data DIV 10000H);
  140.   Word(Data MOD 10000H);
  141. END Long;
  142.  
  143. PROCEDURE ImageEnd;
  144. BEGIN
  145.   Assert(Count=ImageSize,ADR(CorruptImage));
  146.   ImageSize:=0;
  147.   Count:=-1;
  148.   CurImagePtr:=NIL;
  149. END ImageEnd;
  150.  
  151. PROCEDURE FreeImage(VAR Img:Image);
  152. BEGIN
  153.   WITH Img DO
  154.     IF imageData#NIL THEN
  155.       DeallocProc(Img.imageData);
  156.     END;
  157.     depth:=0;
  158.     IF nextImage#NIL THEN
  159.       FreeImage(nextImage^);
  160.     END;
  161.   END;
  162. END FreeImage;
  163.   
  164. PROCEDURE StructText(VAR IText:IntuiText;APen,BPen:Byte;Mode:DrawModeSet;
  165.     Left,Top:INTEGER;Text:ADDRESS;Next:IntuiTextPtr);
  166. BEGIN
  167.   WITH IText DO
  168.     frontPen:=CAST(UByte,APen);
  169.     backPen:=CAST(UByte,BPen);
  170.     drawMode:=Mode;
  171.     leftEdge:=Left;
  172.     topEdge:=Top;
  173.     iTextFont:=NIL;
  174.     iText:=Text;
  175.     nextText:=Next;
  176.   END;
  177. END StructText;
  178.   
  179. PROCEDURE StructGadget(VAR NewGadg:Gadget;Left,Top,Width,Height:INTEGER;
  180.     Flags:GadgetFlagSet;Activ:ActivationFlagSet;Type:CARDINAL;
  181.         Render:ADDRESS;Text:IntuiTextPtr;Excl:LONGSET;ID:INTEGER;
  182.         Next:GadgetPtr);
  183. BEGIN
  184.   WITH NewGadg DO
  185.     nextGadget:=Next;
  186.     leftEdge:=Left;
  187.     topEdge:=Top;
  188.     width:=Width;
  189.     height:=Height;
  190.     flags:=Flags;
  191.     activation:=Activ;
  192.     gadgetType:=Type;
  193.     gadgetRender:=Render;
  194.     selectRender:=NIL;
  195.     gadgetText:=Text;
  196.     mutualExclude:=Excl;
  197.     specialInfo:=NIL;
  198.     gadgetID:=ID;
  199.     userData:=NIL;
  200.   END;
  201. END StructGadget;
  202.  
  203. PROCEDURE ExcludeGadget(Gadgets:GadgetPtr;Window:WindowPtr;
  204.         Requester:RequesterPtr;Mask:LONGSET);
  205. VAR    TempPtr:GadgetPtr;
  206.     Bit:INTEGER;
  207. BEGIN
  208.   Bit:=0;
  209.   WHILE (Gadgets#NIL)AND(Bit<32) DO
  210.     IF (Bit IN Mask)AND(selected IN Gadgets^.flags) THEN
  211.       WITH Gadgets^ DO
  212.         flags:=flags-GadgetFlagSet{selected};
  213.         TempPtr:=nextGadget;
  214.         nextGadget:=NIL;
  215.         RefreshGadgets(Gadgets,Window,Requester);
  216.         nextGadget:=TempPtr;
  217.       END;
  218.     END;
  219.     Gadgets:=Gadgets^.nextGadget;
  220.     INC(Bit);
  221.   END;
  222. END ExcludeGadget;
  223.  
  224. PROCEDURE StructProp(VAR Info:PropInfo;Flags:PropInfoFlagSet;
  225.     HPot,VPot,HBody,VBody:CARDINAL);
  226. BEGIN
  227.   WITH Info DO
  228.     flags:=Flags;
  229.     horizPot:=HPot;
  230.     vertPot:=VPot;
  231.     horizBody:=HBody;
  232.     vertBody:=VBody;
  233.   END;
  234. END StructProp;
  235.  
  236. PROCEDURE StructString(VAR Info:StringInfo;VAR Buffer,UndoBuf:
  237.     ARRAY OF CHAR);
  238. BEGIN
  239.   WITH Info DO
  240.     buffer:=ADR(Buffer);
  241.     undoBuffer:=ADR(UndoBuf);
  242.     bufferPos:=0;
  243.     maxChars:=HIGH(Buffer);
  244.     dispPos:=0;
  245.   END;
  246.   Assert(HIGH(UndoBuf)>=Info.maxChars,
  247.     ADR("StringGadget: UndoBuf too small"));
  248. END StructString;
  249.  
  250. PROCEDURE LinkItems(ItemPtr:MenuItemPtr);
  251. VAR    TopEdge:INTEGER;
  252. BEGIN
  253.   TopEdge:=0;
  254.   WHILE ItemPtr#NIL DO
  255.     WITH ItemPtr^ DO
  256.       topEdge:=TopEdge;
  257.       IF subItem#NIL THEN
  258.         LinkItems(subItem);
  259.       END;
  260.     END;
  261.     INC(TopEdge,StdHeight);
  262.     ItemPtr:=ItemPtr^.nextItem;
  263.   END;
  264. END LinkItems;
  265.   
  266. PROCEDURE LinkMenu(VAR MenuStrip:MenuPtr;Name:ADDRESS;Pos,Width:
  267.     INTEGER;Enabled:BOOLEAN):BOOLEAN;
  268. VAR    TempPtr:MenuPtr;
  269. BEGIN
  270.   IF MenuOK THEN
  271.     Assert(SubItemPtr=NIL,ADR(CorruptMenu));
  272.     AllocProc(TempPtr,SIZE(Menu),CHIPorFAST);
  273.     IF TempPtr#NIL THEN
  274.       TempPtr^.nextMenu:=MenuStrip;
  275.       MenuStrip:=TempPtr;
  276.       WITH MenuStrip^ DO
  277.         leftEdge:=Pos;
  278.         topEdge:=0;
  279.         width:=Width;
  280.         height:=StdHeight;
  281.         IF Enabled THEN
  282.           flags:={menuEnabled};
  283.         ELSE
  284.           flags:={};
  285.         END;
  286.         menuName:=Name;
  287.         firstItem:=ItemPtr;
  288.         LinkItems(ItemPtr);
  289.       END;
  290.       ItemPtr:=NIL;
  291.       RETURN TRUE;
  292.     END;
  293.   END;
  294.   ItemPtr:=NIL;
  295.   MenuOK:=TRUE;
  296.   RETURN FALSE;
  297. END LinkMenu;
  298.  
  299. PROCEDURE InitItem(VAR ItemPtr:MenuItemPtr):BOOLEAN;
  300. VAR    TempPtr:MenuItemPtr;
  301. BEGIN
  302.   AllocProc(TempPtr,SIZE(MenuItem),CHIPorFAST);
  303.   IF TempPtr#NIL THEN
  304.     AllocProc(TempPtr^.itemFill,SIZE(IntuiText),CHIPorFAST);
  305.     IF TempPtr^.itemFill#NIL THEN
  306.       TempPtr^.nextItem:=ItemPtr;
  307.       ItemPtr:=TempPtr;
  308.       RETURN TRUE;
  309.     ELSE
  310.       DeallocProc(TempPtr);
  311.     END;
  312.   END;
  313.   MenuOK:=FALSE;
  314.   RETURN FALSE;
  315. END InitItem;
  316.  
  317. PROCEDURE InitText(VAR TextPtr:IntuiTextPtr;Text:ADDRESS;Flags:
  318.     MenuItemFlagSet);
  319. BEGIN
  320.   WITH TextPtr^ DO
  321.     frontPen:=0;
  322.     drawMode:=jam1;
  323.     IF checkIt IN Flags THEN
  324.       leftEdge:=CheckWidth;
  325.     ELSE
  326.       leftEdge:=0;
  327.     END;
  328.     topEdge:=1;
  329.     iTextFont:=NIL;
  330.     iText:=Text;
  331.   END;
  332. END InitText;
  333.  
  334. PROCEDURE Item(Name:ADDRESS;Width:INTEGER;Flags:MenuItemFlagSet;
  335.     Excl:LONGSET;Cmd:CHAR);
  336. BEGIN
  337.   IF InitItem(ItemPtr) THEN
  338.     WITH ItemPtr^ DO
  339.       leftEdge:=0;
  340.       width:=Width;
  341.       IF checkIt IN Flags THEN
  342.         INC(width,CheckWidth);
  343.       END;
  344.       height:=StdHeight;
  345.       flags:=Flags;
  346.       mutualExclude:=Excl;
  347.       command:=Cmd;
  348.       subItem:=SubItemPtr;
  349.       InitText(CAST(IntuiTextPtr,itemFill),Name,Flags);
  350.     END;
  351.   END;
  352.   SubItemPtr:=NIL;
  353. END Item;
  354.  
  355. PROCEDURE SubItem(Name:ADDRESS;LeftEdge,Width:INTEGER;Flags:
  356.     MenuItemFlagSet;Excl:LONGSET;Cmd:CHAR);
  357. BEGIN
  358.   IF InitItem(SubItemPtr) THEN
  359.     WITH SubItemPtr^ DO
  360.       leftEdge:=LeftEdge;
  361.       width:=Width;
  362.       IF checkIt IN Flags THEN
  363.         INC(width,CheckWidth);
  364.       END;
  365.       height:=StdHeight;
  366.       flags:=Flags;
  367.       mutualExclude:=Excl;
  368.       command:=Cmd;
  369.       subItem:=NIL;
  370.       InitText(CAST(IntuiTextPtr,itemFill),Name,Flags);
  371.     END;
  372.   END;
  373. END SubItem;
  374.  
  375. PROCEDURE UnlinkMenu(VAR MenuStrip:MenuPtr);
  376.  
  377.   PROCEDURE FreeItems(Item:MenuItemPtr);
  378.   BEGIN
  379.     WITH Item^ DO
  380.       IF nextItem#NIL THEN
  381.         FreeItems(nextItem);
  382.       END;
  383.       IF subItem#NIL THEN
  384.         FreeItems(subItem);
  385.       END;
  386.     END;
  387.     DeallocProc(Item);
  388.   END FreeItems;
  389.   
  390. BEGIN
  391.   IF MenuStrip#NIL THEN
  392.     WITH MenuStrip^ DO
  393.       IF nextMenu#NIL THEN
  394.         UnlinkMenu(nextMenu);
  395.       END;
  396.       FreeItems(firstItem);
  397.     END;
  398.     DeallocProc(MenuStrip);
  399.     MenuStrip:=NIL;
  400.   END;
  401. END UnlinkMenu;
  402.   
  403. PROCEDURE MenuNum(Num:CARDINAL):CARDINAL;
  404. BEGIN
  405.   RETURN Num MOD 0020H;
  406. END MenuNum;
  407.  
  408. PROCEDURE ItemNum(Num:CARDINAL):CARDINAL;
  409. BEGIN
  410.   RETURN Num DIV 0020H MOD 0040H;
  411. END ItemNum;
  412.  
  413. PROCEDURE SubNum(Num:CARDINAL):CARDINAL;
  414. BEGIN
  415.   RETURN Num DIV 0800H;
  416. END SubNum;
  417.  
  418. PROCEDURE MakeNum(Menu,Item,SubItem:CARDINAL):CARDINAL;
  419. BEGIN
  420.   RETURN (Menu MOD 20H)+(Item MOD 40H)*0020H+(SubItem MOD 20H)*800H;
  421. END MakeNum;
  422.  
  423. PROCEDURE StructRequest(VAR Req:Requester;Left,Top,Width,Height:INTEGER;
  424.     Gadgets:GadgetPtr;ReqBorder:BorderPtr;Text:IntuiTextPtr;
  425.         BPen:Byte);
  426. BEGIN
  427.   WITH Req DO
  428.     leftEdge:=Left;
  429.     topEdge:=Top;
  430.     width:=Width;
  431.     height:=Height;
  432.     reqGadget:=Gadgets;
  433.     reqBorder:=ReqBorder;
  434.     reqText:=Text;
  435.     flags:=RequesterFlagSet{};
  436.     backFill:=BPen;
  437.   END;
  438. END StructRequest;
  439.  
  440. PROCEDURE AddLine(X,Y:INTEGER);
  441. BEGIN
  442.   Assert((CurBorderPtr#NIL)AND(Count<BorderSize),ADR(CorruptBorder));
  443.   WITH CurBorderPtr^ DO
  444.     x:=X;
  445.     y:=Y;
  446.   END;
  447.   INC(Count);
  448.   INC(CurBorderPtr,SIZE(Point));
  449. END AddLine;
  450.  
  451. PROCEDURE StructBorder(VAR Bord:Border;Left,Top:INTEGER;Pen:Byte;
  452.     Mode:DrawModeSet;NumLines:UByte;Next:BorderPtr);
  453. BEGIN
  454.   Assert((ImageSize=0)AND(BorderSize=0),ADR(CorruptBorder));
  455.   INC(NumLines);
  456.   WITH Bord DO
  457.     leftEdge:=Left;
  458.     topEdge:=Top;
  459.     frontPen:=CAST(UByte,Pen);
  460.     backPen:=0;
  461.     drawMode:=Mode;
  462.     nextBorder:=Next;
  463.     AllocProc(xy,SIZE(Point)*NumLines,CHIPorFAST);
  464.     Count:=0;
  465.     IF xy=NIL THEN
  466.       count:=0;
  467.       BorderSize:=0;
  468.       CurBorderPtr:=NIL;
  469.     ELSE
  470.       count:=NumLines;
  471.       BorderSize:=count;
  472.       CurBorderPtr:=xy;
  473.       AddLine(0,0);
  474.     END;
  475.   END;
  476. END StructBorder;
  477.  
  478. PROCEDURE Rectangle(Width,Height:INTEGER);
  479. BEGIN
  480.   Assert((CurBorderPtr#NIL)AND(BorderSize=5)AND(Count=1),
  481.       ADR(CorruptBorder));
  482.   DEC(Width);
  483.   DEC(Height);
  484.   AddLine(Width,0);
  485.   AddLine(Width,Height);
  486.   AddLine(0,Height);
  487.   AddLine(0,0);
  488. END Rectangle;
  489.  
  490. PROCEDURE BorderEnd;
  491. BEGIN
  492.   Assert(Count=BorderSize,ADR(CorruptBorder));
  493.   BorderSize:=0;
  494.   Count:=-1;
  495.   CurBorderPtr:=NIL;
  496. END BorderEnd;
  497.  
  498. PROCEDURE FreeBorder(VAR Bord:Border);
  499. BEGIN
  500.   WITH Bord DO
  501.     IF xy#NIL THEN
  502.       DeallocProc(xy);
  503.     END;
  504.     count:=0;
  505.     IF nextBorder#NIL THEN
  506.       FreeBorder(nextBorder^);
  507.     END;
  508.   END;
  509. END FreeBorder;
  510.  
  511. BEGIN
  512.   CurImagePtr:=NIL;
  513.   CurBorderPtr:=NIL;
  514.   ItemPtr:=NIL;
  515.   SubItemPtr:=NIL;
  516.   ImageSize:=0;
  517.   BorderSize:=0;
  518.   Count:=-1;
  519.   CommWidth:=48;
  520.   CheckWidth:=24;
  521.   StdHeight:=10;
  522.   MenuOK:=TRUE;
  523.   AllocProc:=FailAlloc;
  524.   DeallocProc:=FailDealloc;
  525. END IntuiStruct.
  526.